#light
namespace FSharp.WebTools
#nowarn "57"

open System
open System.IO
open System.Reflection
open System.Collections
open System.Collections.Generic

open Microsoft.FSharp
open Microsoft.FSharp.Reflection

open FSharp.WebTools
open FSharp.WebTools.ClientExpressions

(*-----------------------------------------------------------------------------------------------*)
module Serializer = begin 
(*-----------------------------------------------------------------------------------------------*)

  let compilationMappingAttr = (type CompilationMappingAttribute)
  let clientClsAttr = (type ClientSideAttribute)
  
  let getGenericTypeDef (t:Type) = 
    if (t.IsGenericType) then t.GetGenericTypeDefinition() else t
    
  let implementsInterface (tyint:Type) (tytest:Type) =
    let tyint = getGenericTypeDef tyint
    tytest.GetInterfaces() |> Array.to_seq |> Seq.filter (fun it -> 
      tyint = getGenericTypeDef it) |> Seq.nonempty;
    
  let (|GenericType|_|) (gt:Type) = fun (o:obj) -> 
    let t = o.GetType();
    if (t.IsGenericType &&  // todo .. IsAssignable from?? maybe? or what?
        (((not gt.IsInterface) && t.GetGenericTypeDefinition().IsSubclassOf(gt)) 
           || (gt.IsInterface && (implementsInterface gt (t.GetGenericTypeDefinition()))) 
           || gt = t.GetGenericTypeDefinition())) then
      Some(t.GetGenericArguments())
    else
      None;
      
  let serverMonadType = (type IServer<obj>).GetGenericTypeDefinition();

  let (|ClientSideClass|_|) (t:Type) =
    if (t.GetCustomAttributes(clientClsAttr, false).Length <> 0) 
      then Some(t) else None

  let tryFindMapping (lookupFunc:Type -> Type option) (t:Type) =
    let tyargs,t = 
      if t.IsGenericType then t.GetGenericArguments(), t.GetGenericTypeDefinition() else [| |], t
    lookupFunc(t) |> Option.bind ( fun v ->
      if (tyargs.Length = 0) then Some(v,[| |]) 
      else Some(v.MakeGenericType(tyargs), tyargs) )
    
  let (|FromExternalMappedClass|_|) (t:Type) = 
    tryFindMapping (mappingProc.LookupSystemType) t

  let (|ToExternalMappedClass|_|) (t:Type) = 
    tryFindMapping (mappingProc.LookupClientType) t
  
  let (|ClientControl|_|) c = 
    match box c with 
    | :? ClientLibrary.IClientControl as ic ->
        match box c with 
        | :? System.Web.UI.Control as cc -> Some(cc)
        | _ -> None
    | _ -> None
    

  let (|ClientControlOrPage|_|) c = 
    match box c with 
    | :? ClientLibrary.IClientPage
    | :? ClientLibrary.IClientControl ->
        match box c with 
        | :? System.Web.UI.Control as cc -> Some(cc)
        | _ -> None
    | _ -> None
    

  let getAllDuplexFields (o:obj) (t:Type) =
    let allProps = 
      t.GetProperties(Enum.combine [BindingFlags.DeclaredOnly; BindingFlags.Public; 
        BindingFlags.NonPublic; BindingFlags.Instance; BindingFlags.Static]) |> Array.to_list 
    
    let isNeutral = t.GetCustomAttributes((type NeutralSideAttribute), false).Length > 0
    let isExternal = t.GetCustomAttributes((type ExternalTypeAttribute), false).Length > 0
    
    // For neutral class we return all fields, for external as well, because they behave like that even though are marked with ClientSide
    // For duplex class we return only marked fields    
    let properties = 
      if (isNeutral || isExternal) then
        allProps |> List.filter ( fun prop -> 
          let cm = (prop.GetCustomAttributes(compilationMappingAttr, false))
          (cm.Length > 0) && ((cm.[0] :?> CompilationMappingAttribute).SourceConstruct = SourceLevelConstruct.Field))     
      else
        allProps |> List.filter ( fun prop -> 
          (prop.GetCustomAttributes((type DuplexFieldAttribute), false).Length > 0) ) 
    
    // Get name & value of properties (fields)          
    properties |> List.map ( fun prop -> (prop.Name, prop.GetValue(o, Array.zero_create 0)) )
    
(*-----------------------------------------------------------------------------------------------*)

  let rec writeSerializedClass (wr:TextWriter) (t:Type) args =
    wr.Write("{{ \"__js_class__\": \"{0}\", ", getClassName t)
    wr.Write("\"__type_args__\": ")
    let tya = Utils.getGenericArgs t |> Array.map (fun t -> Utils.encode (t.AssemblyQualifiedName))
    serializeArray wr (box (tya))
    wr.Write(", \"properties\": {"); 
    args |> Utils.iter_sep ( fun (name, value) -> 
      wr.Write("\""^name); 
      wr.Write("\": "); 
      serializeValue value wr; ) (fun () -> wr.Write(", "); );  
    wr.Write("} }");     

  and serializeClass (wr:TextWriter) o (t:Type) =
    match t with
      | ClientSideClass(t) ->
          let args = getAllDuplexFields o t
          writeSerializedClass wr t args
          
      | FromExternalMappedClass(targetTy, sourceTyArgs) ->
          // Get the "FromExternalType" method and call it to get the right client-side value to serialize
          let fromExt = targetTy.GetMethod("FromExternalType")
          let converted = fromExt.Invoke(null, [| o |])    
          serializeClass wr converted targetTy
          
      | _ -> failwith (String.Format("Can't serialize server-side only class '{0}'!", t.FullName))
      
  and serializeArray (wr:TextWriter) (o:obj) =
    wr.Write("{ \"__js_special__\": \"array\", \"__net_type__\": \"" + 
             (Utils.encode (o.GetType().AssemblyQualifiedName)) + "\", \"members\": "); 
    wr.Write("[");
    (o :?> IEnumerable) |> Utils.seq_iter_sep ( fun (el:obj) ->
        serializeValue el wr
      ) ( fun () ->
        wr.Write(", ");
      );          
    wr.Write("] }");

  and serializeRecord (wr:TextWriter) (ty:Type) v =
    wr.Write("{ \"__js_special__\": \"record\", "); 
    wr.Write("\"__net_type__\": \"" + (Utils.encode ty.AssemblyQualifiedName) + "\", \"members\": ");        
    wr.Write("{ ");
    v |> Utils.iter_sep ( fun ((s,_), o) ->
        wr.Write("\""+s+"\": ")
        serializeValue o wr ) ( fun () -> wr.Write(", ") )
    wr.Write("} }");
      
  and serializeValue (o:obj) (wr:TextWriter) = 
    if (o = null) then
      wr.Write("null")
    else
      let t = o.GetType();
      let info = Type.GetInfo(t)
      match info, o with
        | _, (:? String as s) -> wr.Write(any_to_string s);
        | _, (:? int as n) -> wr.Write(n); 
        | _, (:? bool as n) -> wr.Write(if n then "true" else "false"); 
        | _, (:? float as n) -> wr.Write(n); 
        | _ when t.IsArray -> serializeArray wr o        
        
        // Other natively supported F# types 
        | SumType sum,_ ->
            let t = match Type.GetInfo(t.BaseType) with SumType _ -> t.BaseType | _ -> t                      
            let i = Value.GetSumTagReader t o
            let (name, _) = List.nth sum i
            let args = Value.GetSumRecordReader (t,i) o
            writeSerializedClass wr (type ClientLibrary.Internal.DiscriminatedUnion)
              [ ("name", (box name)); ("args", (box args)); 
                ("__js_special__", box "union");
                ("__net_type__", box (Utils.encode (t.AssemblyQualifiedName))) ]
              
        | TupleType tyargs, _ ->
            let tvals = (Value.GetTupleReader t) o 
            writeSerializedClass wr (type ClientLibrary.Internal.Tuple) 
              [ ("args", (box tvals)); 
                ("__js_special__", box "tuple");
                ("__net_type__", box (Utils.encode (t.AssemblyQualifiedName))) ]
        
        | RecordType flds, _ ->
            let rvals = (Value.GetRecordReader t o) |> Array.to_list
            let fldVals = List.zip flds rvals
            serializeRecord wr t fldVals
            
        | _ -> serializeClass wr o t

(*-----------------------------------------------------------------------------------------------*)

  // serialize control and base classes
  let rec serializeControlTree printSep serializeID instRef (o:obj) (t:Type) (wr:TextWriter) =
    // is it still control?
    let ps = ref printSep
    if (type System.Web.UI.Control).IsAssignableFrom(t) then
      // serialize only client-side controls / pages
      if ((type ClientLibrary.IClientControl).IsAssignableFrom(t)) ||
          ((type ClientLibrary.IClientPage).IsAssignableFrom(t)) then
          
        // write fields as a state changes
        let args = getAllDuplexFields o t
        args |> List.iter ( fun (name, value) -> 
          if (!ps) then wr.Write(",\n"); else ps := true
          serializeValue (box (false, instRef, name, value)) wr ) 
        
        if (serializeID && (o :? ClientLibrary.IClientControl)) then
          let ctl = o :?> System.Web.UI.Control
          if (!ps) then wr.Write(",\n"); else ps := true
          serializeValue (box (true, instRef, "ID", ctl.ID)) wr  
        
          
      // try base class
      serializeControlTree !ps false instRef o (t.BaseType) wr
    else
      !ps
  
  // serialize control and controls inside the control
  let rec serializeControlState printSep instRef (o:obj) (t:Type) (wr:TextWriter) =
    let ps = ref printSep
    let instRef = 
      match o with 
        | ClientControlOrPage ctl -> 
            let instRef =
              match ctl with
                | :? System.Web.UI.Page -> "thisPage"
                | _ -> instRef + "." + ctl.ClientID 
            ps := serializeControlTree (!ps) true instRef o t wr
            instRef
        | _ -> instRef
    match o with
      | :? System.Web.UI.Control as ctl -> 
          ctl.Controls |> Seq.untyped_iter (fun (c:obj) ->
            ps := serializeControlState (!ps) instRef c (c.GetType()) wr)
      | _ -> ();
    !ps  
      
  let rec serializePageState (o:obj) (t:Type) (wr:TextWriter) = 
    match t with
    | null -> failwith "No client-side page in the hierarchy!"
    | ClientSideClass(t) ->
        wr.Write("{ \"result\": null, \"state\": [");
        serializeControlState false "" o t wr |> ignore
        wr.Write("]}");
    | _ -> serializePageState o (t.BaseType) wr
                  
(*-----------------------------------------------------------------------------------------------*)

  let serialize (o:obj) (wr:TextWriter) = 
    let t = o.GetType()
    match o with
      | GenericType serverMonadType _ -> 
          let intf = t.GetInterfaces() |> Array.find (fun itf ->
                        (getGenericTypeDef itf = serverMonadType) )
          let diff = intf.GetMethod("GetServerStateDiff").Invoke(o, [| |])
          let value = intf.GetMethod("GetServerValue").Invoke(o, [| |])
          
          wr.Write("{ \"result\": ");
          serializeValue value wr
          wr.Write(", \"state\": [");
          
          let rec getControlClientRef (c:obj) =
            match c with
            | :? System.Web.UI.Page -> "thisPage"
            | ClientControl ctl ->
                let p = getControlClientRef (box ctl.Parent)
                p + "." + ctl.ClientID
            | :? System.Web.UI.Control as ctl -> getControlClientRef (box ctl.Parent)
            | _ -> failwith "State modifications are allowed only on controls!"
            
          let state:(bool*obj*string*obj) list = unbox diff
          state |> Utils.iter_sep (fun (isProp,inst,prop,value) ->
              let objEval = getControlClientRef inst
              serializeValue (box (isProp,objEval,prop,value)) wr
            ) (fun () -> wr.Write(", "); )
          
          wr.Write("] }");
      | _ -> failwith "Must return http value!"

(*-----------------------------------------------------------------------------------------------*)
// ASP.NET integration for the deserializator

  type IInstantiator =
    abstract Get : Type -> obj
    abstract EnterScope : PropertyInfo -> IInstantiator

  let rec objectInstantiator () =          
    { new IInstantiator 
      with Get(ty) = Activator.CreateInstance(ty)
      and EnterScope(s) = objectInstantiator () }
    
  let rec findControl (c:#System.Web.UI.Control) id =    
    c.Controls |> Seq.untyped_to_typed |> Utils.tryfind_any (fun (c:System.Web.UI.Control) -> 
      if (c.ID = id) then Some c else findControl c id ) 

  let rec findControlByClient (c:#System.Web.UI.Control) id =    
    c.Controls |> Seq.untyped_to_typed |> Utils.tryfind_any (fun (c:System.Web.UI.Control) -> 
      if (c.ClientID = id) then Some c else findControlByClient c id ) 

  let rec pageInstantiator (inst:System.Web.UI.Control) =
    { new IInstantiator 
      with Get(ty) = 
        if (type System.Web.UI.Control).IsAssignableFrom(ty) then 
          if (ty.IsAssignableFrom(inst.GetType())) then 
            (inst :> obj) 
          else failwith "Couldn't find specified control!"
        else Activator.CreateInstance(ty)
        
      and EnterScope(pi) =     
        if (type System.Web.UI.Control).IsAssignableFrom(pi.PropertyType) then 
          match (findControl inst pi.Name) with
          | Some(c) -> pageInstantiator(c);
          | _ -> failwithf "Can't find control '%s'!" pi.Name 
        else
          pageInstantiator(inst); }

(*-----------------------------------------------------------------------------------------------*)

  // Decode type encoded in a string
  let rec decodeType (p:string) =
    let p = if (p.StartsWith("native:")) then Utils.encode (p.Substring(7)) else p // workaround for "lib.js" this is also a huge security hole
    let name = Utils.decode p
    Type.GetType(name)       
     

  /// Deserialize primitive value
  /// - boxed value can contain either float, int, bool, string or null of type object
  ///   given expected type, guesses some conversions, but it can be obj..
  and deserializePrimitive (o:obj) ty =
    if (o = null) then o else
    let objTy = o.GetType()
    
    // matching type?
    if (objTy = ty) then o 
    elif (ty = (type obj)) then o else 
    match o with
      | :? float as f ->
          // convert from float..
          if (ty = (type float32)) then box (float32 f)
          elif (ty = (type Decimal)) then box (new Decimal(f))
          else failwithf "Can't convert %s to %s" objTy.Name ty.Name
          
      | :? int as i ->   
          // convert from int   
          if   (ty = (type int16))    then box (int16 i)
          elif (ty = (type int64))    then box (int64 i)
          elif (ty = (type uint16))   then box (uint16 i)
          elif (ty = (type uint32))   then box (uint32 i)
          elif (ty = (type uint64))   then box (uint64 i)
          elif (ty = (type byte))     then box (byte i)
          elif (ty = (type float))    then box (float i)
          elif (ty = (type float32))  then box (float32 i)
          else failwithf "Can't convert %s to %s" objTy.Name ty.Name
          
      | :? bool as b ->      
          // convert from bool
          failwithf "Can't convert %s to %s" objTy.Name ty.Name
          
      | :? string as s ->      
          // convert from string
          if   (ty = (type char) && s.Length = 1)    then box (s.[0])
          else failwithf "Can't convert %s to %s" objTy.Name ty.Name
      | _ -> 
        assert(false)
        
        
  /// Deserialize array
  /// - type is deserialized when deserializing special, members should be JSON array
  let rec deserializeArray instantiator membs (ty:Type) (expTy:Type) = 
    let elty = if (expTy <> null && expTy.IsArray) then expTy.GetElementType() else ty.GetElementType()
    let args = membs |> List.map (fun v -> deserializeValue instantiator v elty) 
    let arr = Array.CreateInstance(elty, args.Length)
    args |> List.iteri ( fun i el -> arr.SetValue(el, i) )
    (box arr)


  /// Deserialize class
  /// - { "__js_class__": "..type..", "properties": { ... } }
  /// tyname specifies name of the type, ty is expected .NET type, props is JSON Object with properties
  and deserializeClass (instantiator:IInstantiator) props (objTy:Type) (expTy:Type) = 
    
    // Workaround for generics
    let ty = if (Utils.getGenericTypeDef objTy) = (Utils.getGenericTypeDef expTy) then expTy else objTy    
    
    match props with 
    | Object pvals ->         
        // Create instance & Set all the mutbale mixed client-server fields
        let objVal = instantiator.Get(ty)        
        pvals |> Map.iter (fun key value ->
            let pi = ty.GetProperty(key);
            if (not pi.CanWrite) 
              then failwithf "Deserialization failed - field '%A' is not mutable!" key
            let s = pi.PropertyType
            let desVal = deserializeValue (instantiator.EnterScope(pi)) value pi.PropertyType
            let setter = pi.GetSetMethod()
            setter.Invoke(objVal, [|desVal|]) |> ignore
          ) 

        // Is the object external with an explicit conversion?
        match ty, objVal with 
        | ToExternalMappedClass(targetTy, sourceTyArgs), _ ->
            // Get the "ToExternalType" method and call it to get the right client-side value to serialize
            let fromExt = ty.GetMethod("ToExternalType")
            let converted = fromExt.Invoke(objVal, [| |])    
            converted
        | _ -> objVal
    | _ -> failwith "JSON error - 'properties' of a class must be an object!"


  /// Deserialize record
  and deserializeRecord instantiator (membs:JsonValue list) ty = 
    match Type.GetInfo(ty) with
    | RecordType assoc ->
        let cons = Value.GetRecordConstructor ty
        let membs = membs |> List.fold_left (fun st vl ->
          match vl with 
          | Object(map) -> let (s, v) = List.hd (Map.to_list map) in Map.add s v st
          | _ -> failwith "JSON error - incorrectly encoded record!" ) Map.empty
        let args = List.map (fun (n,ty) -> 
          let vl = Map.find n membs 
          deserializeValue instantiator vl ty) assoc 
        cons (args |> List.to_array)
    | _ -> failwith "JSON error - record type is not a record!"
  
  
  /// Deserialize union          
  and deserializeUnion instantiator tag (membs:JsonValue list) ty = 
    match (Type.GetInfo ty) with
    | SumType sumTy ->
        let _, _, conv = Value.GetSumTagConverters ty
        
        // WORKAROUND!! why does it say it's op_ColonColon??? 
        let tag = 
          match tag with 
          | "op_ColonColon" -> "Cons" 
          | "op_Nil" -> "Nil"
          | _ -> tag
        
        let idx = (conv tag)
        let name, args = List.nth sumTy idx
        let objArgs = List.map2 (fun (s,ty) vl -> 
                                  deserializeValue instantiator vl ty
                                ) args membs
        Value.GetSumConstructor (ty,idx) (objArgs |> List.to_array)
    | _ ->
        failwithf "JSON error - union type is not a union"

  /// Deserialize union          
  and deserializeTuple instantiator (membs:JsonValue list) ty = 
    match (Type.GetInfo ty) with
    | TupleType a ->
        let args = List.map2 (fun v ty -> deserializeValue instantiator v ty) membs a 
        (Value.GetTupleConstructor ty) (args |> List.to_array)
    | _ ->
        failwithf "JSON error - tuple type is not a tuple" 
    
  /// Deserialize object
  /// - anything in { .. } is an object, so this determines if it's class or special
  ///   and calls appropriate deserializer
  and deserializeObject instantiator (props:Map<string,JsonValue>) (expTy:Type) = 
    match (Map.tryfind "__js_class__" props, Map.tryfind "__js_special__" props) with
    
    // { "__js_class__": "type", "properties: { ... } }
    | Some(Primitive (:? string as s)), None -> 
        match Map.tryfind "properties" props, Map.tryfind "__type_args__" props with
        | Some p, None -> 
            deserializeClass instantiator p (decodeType s) expTy
        | Some p, Some(Object(args)) -> 
            let targs = unbox(deserializeObject instantiator args (type string[])) 
            let targs = targs |> Array.map decodeType
            deserializeClass instantiator p (Utils.makeGenericTypeDef (decodeType s) targs) expTy
        | _ -> failwith "JSON error - class has no 'properties' property!"
        
    // { "__js_special__": ... }
    | None, Some(Primitive spec) ->        
        // extract type from "type" property
        let typ = 
          match Map.tryfind "__net_type__" props with 
            | Some (Primitive(:? string as t)) -> decodeType t
            | _ -> failwith "JSON error - __js_special__ is missing 'type'!"

        // WORKAROUND: another naughty workaround that is needed, since we don't support generics properly
        //             (we'd like to, but we can't)
        // (if it looks that it is good idea to use expected type, than we will use it, because it may be more 
        //  specific - for example List<Something> instead of List<obj>)
        let etD = Utils.getGenericTypeDef expTy
        let rtD = Utils.getGenericTypeDef typ
        let typ = if (etD = rtD) then expTy else typ
        
        // extract "members" property value
        let membs = 
          match Map.tryfind "members" props with 
            | Some (Array a) -> a
            | _ -> failwith "JSON error - __js_special__ is missing 'members'!"
          
        // what kind of special is it?    
        match unbox (deserializePrimitive spec (type string)) with
        | "record" -> deserializeRecord instantiator membs typ
        | "array" ->  deserializeArray  instantiator membs typ expTy
        | "union" ->  let tag = 
                        match Map.tryfind "tag" props with 
                          | Some(Primitive(:? string as s)) -> s 
                          | _ -> failwith "JSON error - union is missing 'tag'!"
                      deserializeUnion  instantiator tag membs typ
        | "tuple" ->  deserializeTuple  instantiator membs typ
        | _ ->        failwith "JSON error - Unknown or incorrect special type!"        
    | None, None ->   failwith "JSON error - invalid serialized object - contains neither special nor class type!"
    | _ ->            failwith "JSON error - invalid serialized object - contains both special and class type or invalid class name!"
  
  
  /// Deserialize any value
  /// - this can be either class/special thing or primitive
  and deserializeValue (instantiator) jsv ty =
    match jsv with 
    | Object o -> deserializeObject instantiator o ty
    | Primitive p -> deserializePrimitive p ty
    | _ -> failwith "Unexpected raw JSON array - arrays are supported only in __js_special__!"


  /// Deserialize arguments for a functon call
  let deserializeArguments instantiator args (expectedTypes:Type[]) = 
    let tyl = List.of_array expectedTypes
    match args with
      | Array ar     when expectedTypes.Length = ar.Length -> 
          List.map2 (fun v ty -> (deserializeValue instantiator v ty) ) ar tyl |> Array.of_list
      | a when expectedTypes.Length = 1 -> 
          [| box (deserializeValue instantiator a expectedTypes.[0]) |]
      | _ -> failwith "JSON error - Unexpected arguments format!"


  /// Deserialize request...
  /// - expected instance type and expectedTypes are used to determine number of arguments 
  ///   or type of primitive values
  let deserialize page (expectedInst:Type option, expectedTypes:Type[]) str = 

    // Run the parser..
    let jsonObj = 
      try
        Json_pars.value Json_lex.token (Lexing.from_string str)
      with e -> 
        failwithf "error parsing JSON:\n %s" str
    
    // Can be instance call:
    // - { "control": ".. target name ..", "instance", { .. }, "arguments": [ ... ] }
    // or arguments for a static member call:
    // - [ ... ]
    match jsonObj with
    | Object props ->
        let quad = 
          (expectedInst, Map.tryfind "control" props, 
           Map.tryfind "instance" props, Map.tryfind "arguments" props)
           
        match quad with
        | Some(instTyp), Some(Primitive ctrl), Some(inst), Some(args) ->
            let ctrl = unbox (deserializePrimitive ctrl (type string))
            let caller = 
              if (ctrl = "thisPage") then (page :> System.Web.UI.Control) else
              match (findControlByClient (page :> System.Web.UI.Control) ctrl) with
              | Some(c) -> c
              | _ -> failwith "Couldn't find control!"
            let inst = (deserializeValue (pageInstantiator caller) inst instTyp)
            let args = deserializeArguments (objectInstantiator ()) args expectedTypes
            inst, args
            
        | None, None, None, Some(args) ->
            null, deserializeArguments (objectInstantiator ()) args expectedTypes
            
        | _ -> failwith "JSON Error - Missing instance/control for member method or got instance for static method."
    | _ ->     failwith "JSON Error - Top level serialized value must be object with 'arguments' and possibly 'instance'."
end